home *** CD-ROM | disk | FTP | other *** search
/ Visual Basic Source Code / Visual Basic Source Code.iso / vbsource / balloo1 / balloonm.bas < prev    next >
BASIC Source File  |  1999-09-05  |  12KB  |  335 lines
  1. Attribute VB_Name = "BalloonMod"
  2. '------------------------------------------------
  3. ' ________  Copyright EAguirre (c)1999
  4. '(        ) eaguirre@comtrade.com.mx
  5. '(  ______) Be carefull with subclassing a window
  6. ' \/
  7. ' BalloonToolTip
  8. '-------------------------------------------------
  9. Option Explicit
  10.  
  11. Const GWL_WNDPROC = -4
  12. Const HeightCaption = 325 'Twips
  13.  
  14. Declare Function CallWindowProc Lib "user32" Alias "CallWindowProcA" (ByVal lpPrevWndFunc As Long, ByVal hwnd As Long, ByVal Msg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
  15. Declare Function SetWindowLong Lib "user32" Alias "SetWindowLongA" (ByVal hwnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long
  16.  
  17. Dim oldAddress As Long              'Old address of the WndProc
  18. Dim BalloonForm As Form             'Balloon Form Instance
  19. Dim HookedForm As Form              'Hooked Form (subclassing)
  20. Dim BalloonCtrl As Control          'Control under the mouse
  21. Dim TipCtrl As Control              'Tip control
  22. Dim BalloonBox As RECT              'Balloon Box coordinates
  23.  
  24. Function HiWord(dw As Long) As Long
  25.     If dw And &H80000000 Then
  26.         HiWord = (dw \ 65536) - 1
  27.     Else
  28.         HiWord = dw \ 65536
  29.     End If
  30. End Function
  31.  
  32. Function LoWord(dw As Long) As Long
  33.     If dw And &H8000& Then
  34.         LoWord = &H8000 Or (dw And &H7FFF&)
  35.     Else
  36.         LoWord = dw And &HFFFF&
  37.     End If
  38. End Function
  39.  
  40. Public Sub InitProc(ByRef frmParent As Form)
  41.     If frmParent Is Nothing Then Exit Sub
  42.     'Hook the window
  43.     Set HookedForm = frmParent
  44.     'Assign the TipControl
  45.     For Each TipCtrl In HookedForm
  46.       If TypeOf TipCtrl Is BalloonTip Then Exit For
  47.     Next TipCtrl
  48.    'Creating a balloon window
  49.     Set BalloonForm = New frmBalloon
  50.    'Set the new WndProc to the parent form
  51.     oldAddress = SetWindowLong(HookedForm.hwnd, GWL_WNDPROC, AddressOf WndProc)
  52. End Sub
  53.  
  54. Sub TerminateProc()
  55.   Dim TProc As Long
  56.   If HookedForm Is Nothing Then Exit Sub
  57.   'Restore the old window procedure
  58.   TProc = SetWindowLong(HookedForm.hwnd, GWL_WNDPROC, oldAddress)
  59.   'Restore memory
  60.   Unload BalloonForm
  61.   Set BalloonForm = Nothing
  62.   Set HookedForm = Nothing
  63.   Set TipCtrl = Nothing
  64. End Sub
  65.  
  66. Function WndProc(ByVal hwnd As Long, ByVal uMsg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
  67.  
  68. On Error Resume Next
  69. 'Calling the original Window Procedure
  70. WndProc = CallWindowProc(oldAddress, hwnd, uMsg, wParam, lParam)
  71. 'Subclassing the original form
  72. Select Case uMsg
  73.     Case WM_SETCURSOR
  74.         Dim wndhWnd As Long
  75.         Dim mouseMsg As Long
  76.         Dim ctrl As Control
  77.               
  78.         ' wParam holds the handle of the window under the cursor
  79.         wndhWnd = wParam
  80.         ' High word of lParam = Mouse Message
  81.         mouseMsg = HiWord(lParam)
  82.            
  83.         If mouseMsg = WM_MOUSEMOVE Then
  84.           If BalloonCtrl.hwnd <> wndhWnd Then
  85.              HideTip
  86.              'Search the control under cursor
  87.              For Each ctrl In HookedForm.Controls
  88.                If ctrl.hwnd <> wndhWnd Then
  89.                'hWnd property not supported or not found yet
  90.                Else
  91.                  If Len(ctrl.ToolTipText) > 0 Then
  92.                    Set BalloonCtrl = ctrl
  93.                    With ctrl
  94.                      TipCtrl.Text = .ToolTipText
  95.                      .ToolTipText = ""
  96.                      'Turn on the timer
  97.                      BalloonForm.Controls(0).Enabled = True
  98.                    End With
  99.                  End If
  100.                  Exit For
  101.                End If
  102.              Next
  103.            End If
  104.         End If
  105.         'Hide Tip in case of mouse click's
  106.         If (mouseMsg = WM_LBUTTONDOWN) Or (mouseMsg = WM_MBUTTONDOWN) _
  107.            Or (mouseMsg = WM_RBUTTONDOWN) Then HideTip
  108.         
  109.     Case WM_HSCROLL, WM_KEYDOWN, WM_KEYUP, WM_VSCROLL
  110.       HideTip
  111. End Select
  112. End Function
  113.  
  114. Private Sub HideTip()
  115. Dim mCount As Integer
  116. If Not (BalloonCtrl Is Nothing) Then
  117.      With BalloonForm
  118.         'Turn off the timer
  119.         .Controls(0).Enabled = False
  120.         'Hide Balloon Form
  121.         .Hide
  122.      End With
  123.     'Restore Values of the Control
  124.      BalloonCtrl.ToolTipText = TipCtrl.Text
  125.      TipCtrl.Text = ""
  126.      Set BalloonCtrl = Nothing
  127. End If
  128. End Sub
  129.  
  130. Private Sub ChangeStyle()
  131. Dim Reg(2) As Long
  132. Dim P(3) As POINTAPI
  133. Dim Box As RECT
  134. Dim w As Single, h As Single
  135. 'Copy values to variables for optimization
  136. w = BalloonForm.ScaleWidth: h = BalloonForm.ScaleHeight
  137. 'Establish the form of the balloon depending the Orientation
  138. 'Property.
  139. Select Case TipCtrl.Orientation
  140.     Case North, South
  141.        P(0).x = (w / 2) - (w * 0.15): P(0).y = h / 2
  142.        P(1).x = (w / 2) + (w * 0.15): P(1).y = h / 2
  143.        P(2).x = w / 2
  144.        Box.Left = 0: Box.Right = w
  145.        If TipCtrl.Orientation = North Then
  146.          Box.Top = 0:   Box.Bottom = h - (h * 0.1)
  147.          P(2).y = h
  148.        Else
  149.          Box.Top = h * 0.1: Box.Bottom = h
  150.          P(2).y = 0
  151.        End If
  152.     Case NE, Sw
  153.        P(0).x = (w / 2) - (w * 0.15): P(0).y = (h / 2) - (h * 0.15)
  154.        P(1).x = (w / 2) + (w * 0.15): P(1).y = (h / 2) + (h * 0.15)
  155.        Box.Left = 0: Box.Right = w
  156.        If TipCtrl.Orientation = NE Then
  157.          Box.Top = 0: Box.Bottom = h - (h * 0.1)
  158.          P(2).x = 0: P(2).y = h
  159.        Else
  160.          Box.Top = h * 0.1: Box.Bottom = h
  161.          P(0).x = (w / 2) - (w * 0.15): P(0).y = (h / 2) - (h * 0.15)
  162.          P(1).x = (w / 2) + (w * 0.15): P(1).y = (h / 2) + (h * 0.15)
  163.          P(2).x = w: P(2).y = 0
  164.        End If
  165.     Case East, West
  166.        P(0).x = (w / 2): P(0).y = (h / 2) + (h * 0.15)
  167.        P(1).x = (w / 2): P(1).y = (h / 2) - (h * 0.15)
  168.        P(2).y = h / 2
  169.        Box.Top = 0: Box.Bottom = h
  170.        If TipCtrl.Orientation = East Then
  171.          Box.Left = w * 0.1: Box.Right = w
  172.          P(2).x = 0
  173.        Else
  174.          Box.Left = 0: Box.Right = w - (w * 0.1)
  175.          P(2).x = w
  176.        End If
  177.     Case NW, SE
  178.        P(0).x = (w / 2) - (w * 0.15): P(0).y = (h / 2) + (h * 0.15)
  179.        P(1).x = (w / 2) + (w * 0.15): P(1).y = (h / 2) - (h * 0.15)
  180.        Box.Left = 0: Box.Right = w
  181.        If TipCtrl.Orientation = NW Then
  182.          Box.Top = 0: Box.Bottom = h - (h * 0.1)
  183.          P(2).x = w: P(2).y = h
  184.        Else
  185.          Box.Top = h * 0.1: Box.Bottom = h
  186.          P(2).x = 0: P(2).y = 0
  187.        End If
  188. End Select
  189. 'Create Region 1: Balloon Body
  190. Select Case TipCtrl.Style
  191.     Case Rectangle
  192.       Reg(0) = CreateRectRgn(Box.Left, Box.Top, Box.Right, Box.Bottom)
  193.     Case Balloon
  194.       Reg(0) = CreateEllipticRgn(Box.Left, Box.Top, Box.Right, Box.Bottom)
  195.     Case Round_Rectangle
  196.       Reg(0) = CreateRoundRectRgn(Box.Left, Box.Top, Box.Right, Box.Bottom, w * 0.2, h * 0.2)
  197. End Select
  198. 'Create Region 2: Tail of the balloon
  199. Reg(1) = CreatePolygonRgn(P(0), 3, 0)
  200. 'Combine regions for balloon shape
  201. CombineRgn Reg(1), Reg(1), Reg(0), RGN_OR
  202. 'Change the Balloonform shape
  203. SetWindowRgn BalloonForm.hwnd, Reg(1), True
  204. 'Adjust de box for fitting the label text
  205. 'in the case of elliptic regions
  206. If TipCtrl.Style = Balloon Then
  207.     BalloonBox.Bottom = Box.Bottom - h * 0.15
  208.     BalloonBox.Left = Box.Left + w * 0.15
  209.     BalloonBox.Right = Box.Right - w * 0.15
  210.     BalloonBox.Top = Box.Top + h * 0.15
  211. Else
  212.     BalloonBox.Bottom = Box.Bottom
  213.     BalloonBox.Left = Box.Left
  214.     BalloonBox.Right = Box.Right
  215.     BalloonBox.Top = Box.Top
  216. End If
  217. End Sub
  218.  
  219. Private Sub DrawLabel()
  220. Dim lngFormat As Long
  221. Dim new_box As RECT
  222. Dim sngArea As Single
  223. Dim oldArea As Single
  224. Dim lngHeight As Long, lngWidth As Long
  225.  
  226. 'Clear control's device context and change display properties
  227. BalloonForm.BackColor = TipCtrl.BackColor
  228. BalloonForm.ForeColor = TipCtrl.ForeColor
  229. Set BalloonForm.Font = TipCtrl.Font
  230. BalloonForm.Cls
  231. 'Set the text format
  232. If TipCtrl.WordBreak = yes Then lngFormat = DT_WORDBREAK
  233. If TipCtrl.TextAlign = To_Left Then
  234.     lngFormat = lngFormat Or DT_LEFT
  235. ElseIf TipCtrl.TextAlign = To_Center Then
  236.     lngFormat = lngFormat Or DT_CENTER
  237. Else
  238.     lngFormat = lngFormat Or DT_RIGHT
  239. End If
  240. 'Calculate the rectangle
  241. DrawText BalloonForm.hdc, TipCtr